home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / Dev / Amiga-E / E_v3.2a_extras / PdSrc / Lang / Yax / Yax.e < prev   
Text File  |  1992-09-02  |  23KB  |  743 lines
  1. /* YAX (Yet Another Instruction Code Set) Interpreter v1.2
  2.    simple procedural/(functional) language with lisp-lookalike syntax.
  3.    eats sources with extension .yax for dinner.               */
  4.  
  5. -> note: code is a little oldfashioned by now
  6.  
  7. OPT STACK=25000     /* we do heavy recursion */
  8.  
  9. OBJECT var          /* this is where we store our runtime values */
  10.   type:LONG
  11.   name:LONG
  12.   value:LONG
  13. ENDOBJECT
  14.  
  15. /* intermediate codes */
  16. ENUM ENDSOURCE,VALUE,ISTRING,IDENT,LBRACKET,RBRACKET
  17.  
  18. /* keywords */
  19. ENUM FWRITE=100,FADD,FEQ,FUNEQ,FSUB,FMUL,FDIV,FAND,FORX,FNOT,FIF,FDO,
  20.      FSELECT,FSET,FFOR,FWHILE,FUNTIL,FDEFUN,FLAMBDA,FAPPLY,FREADINT,
  21.      FARRAY,FGREATER,FSMALLER,FLOCATE,FCLS,FDUMP,FWINDOW,FTELL,FTOLD,
  22.      FSEE,FSEEN,FSTRING,FREAD,FGET,FPUT,FFILELEN,FLINE,FPLOT,FBOX,
  23.      FMOUSEX,FMOUSEY,FMOUSE,FTEXT,FABS,FMOD,FEOR,FSWAP,FPOWER,FREQ,
  24.      FINC,FDEC,FRND,FRNDQ,FKICK,FWHEN,FELSE,FWIN,FSCREEN,FMESSAGE,
  25.      FGADGET,FGADNUM,FHEX,FEXIT,LAST
  26.  
  27. CONST KEYWORDSIZE=8,
  28.       NRKEYWORDS=LAST-99,
  29.       IDENTNAMESPACE=30000,
  30.       VARSTACKSPACE=50000,
  31.       MAXARGS=5,
  32.       ERLEN=60
  33.  
  34. /* errors */
  35. ENUM ER_WORKSPACE=1,ER_BUF,ER_GARBAGE,ER_SYNTAX,ER_EXPKEYWORD,ER_EXPRBRACKET,
  36.      ER_EXPEXP,ER_QUOTE,ER_COMMENT,ER_INFILE,ER_SOURCEMEM,ER_EXPIDENT,
  37.      ER_ARGS,ER_TYPE,ER_EXPLBRACKET,ER_STACK,ER_ALLOC,ER_ARRAY,ER_FILE,
  38.      ER_GFXWIN,ER_VALUES,ER_KICK
  39.  
  40. /* variable types */
  41. ENUM TINTEGER=1,TSTRING,TFUNC,TARRAY
  42.  
  43. DEF source,slen,erpos=NIL,
  44.     ilen,ibuf,ipos:PTR TO INT,p:PTR TO INT,idents,
  45.     name[100]:STRING,wfile,
  46.     inputbuf[100]:STRING,winspec[100]:STRING,
  47.     vartop,varbottom,vars,rec,globvar,
  48.     infile,outfile,oldout,oldin,ownstdin,
  49.     gfxwindow=NIL,curwindow=NIL,curscreen=NIL,gadnum=-1
  50.  
  51. PROC main()
  52.   WriteF(''); ownstdin:=stdout
  53.   loadsource()
  54.   ilen:=Mul(slen,4)+1000       /* guess the needed workspace */
  55.   ibuf:=New(ilen+10)
  56.   idents:=String(IDENTNAMESPACE)
  57.   vars:=New(VARSTACKSPACE)
  58.   vartop:=vars; varbottom:=vars
  59.   IF (ibuf=NIL) OR (idents=NIL) OR (vars=NIL)
  60.     error(ER_WORKSPACE)
  61.   ELSE 
  62.     lexanalyse()               /* translate to intermediate format */
  63.     p:=ibuf
  64.     WHILE p[]<>ENDSOURCE DO eval()       /* run the code */
  65.   ENDIF
  66.   error(0)
  67. ENDPROC
  68.  
  69. PROC lexanalyse()
  70.   DEF pos,end,c,count,ident[50]:STRING,pos2,keypos,a,nr,ident2[50]:STRING
  71.   pos:=source; end:=pos+slen; ipos:=ibuf; erpos:=pos
  72.   StrCopy(idents,' ',1)
  73.   loop:
  74.   c:=pos[]++
  75.   IF c>96                          /* an identifier */
  76.     pos2:=pos-1
  77.     WHILE pos[]++>96 DO NOP; DEC pos
  78.     StrCopy(ident,pos2,pos-pos2)
  79.     StrCopy(ident2,ident,ALL)
  80.     StrAdd(ident,'..............',ALL)
  81.     keypos:={keywords}
  82.     nr:=0
  83.     FOR a:=1 TO NRKEYWORDS         /* lookup keywords */
  84.       IF StrCmp(ident,keypos,KEYWORDSIZE)
  85.         nr:=99+a
  86.         JUMP found
  87.       ENDIF
  88.       keypos:=keypos+KEYWORDSIZE
  89.     ENDFOR
  90.     found:
  91.     IF nr>0                        /* keyword */
  92.       iword(nr)
  93.     ELSE                           /* own identifier */
  94.       iword(IDENT)
  95.       StrCopy(ident,' ',1)
  96.       StrAdd(ident,ident2,ALL)
  97.       StrAdd(ident,' ',1)
  98.       pos2:=InStr(idents,ident,0)
  99.       IF pos2=-1
  100.         ilong(EstrLen(idents)+idents)
  101.         StrAdd(idents,ident2,ALL)
  102.         StrAdd(idents,' ',1)
  103.         IF EstrLen(idents)=StrMax(idents) THEN error(ER_WORKSPACE)
  104.       ELSE
  105.         ilong(pos2+idents+1)
  106.       ENDIF
  107.     ENDIF
  108.   ELSE
  109.     SELECT c                       /* anything else */
  110.       CASE " "
  111.         IF pos<end THEN JUMP loop
  112.       CASE "("
  113.         iword(LBRACKET)
  114.         erpos:=pos-1
  115.         ilong(erpos)
  116.       CASE ")"; iword(RBRACKET)
  117.       CASE "+"; iword(FADD)
  118.       CASE "-"
  119.         IF pos[]=" "
  120.           iword(FSUB)
  121.         ELSE
  122.           iword(VALUE)
  123.           ilong(-Val(pos,{c}))
  124.           IF c=0 THEN error(ER_GARBAGE) ELSE pos:=pos+c
  125.         ENDIF
  126.       CASE "*"; iword(FMUL)
  127.       CASE "/"
  128.         IF pos[]<>"*"
  129.           iword(FDIV)
  130.         ELSE                       /* comment (like this one) */
  131.           INC pos
  132.           WHILE pos-1<end
  133.             INC count
  134.             IF (pos[]++="*") AND (pos[]="/") THEN JUMP out
  135.           ENDWHILE
  136.           error(ER_COMMENT)
  137.           out:
  138.           INC pos
  139.         ENDIF
  140.       CASE "="
  141.         iword(FEQ)
  142.       CASE ">"
  143.         iword(FGREATER)
  144.       CASE "<"
  145.         iword(FSMALLER)
  146.       CASE "?"
  147.         iword(FUNEQ)
  148.       CASE "'"                     /* string constant */
  149.         iword(ISTRING)
  150.         count:=0; pos2:=pos
  151.         WHILE pos[]++<>"'"
  152.           INC count
  153.           IF pos=end THEN error(ER_QUOTE)
  154.         ENDWHILE
  155.         iword(count)
  156.         ilong(pos2)                /* char adress */
  157.       CASE 10
  158.         IF pos<end THEN JUMP loop
  159.       CASE 0
  160.         pos:=end
  161.       CASE 9
  162.         IF pos<end THEN JUMP loop
  163.       DEFAULT
  164.         iword(VALUE)
  165.         ilong(Val(pos--,{c}))
  166.         IF c=0 THEN error(ER_GARBAGE) ELSE pos:=pos+c
  167.     ENDSELECT
  168.   ENDIF
  169.   IF pos<end THEN JUMP loop
  170.   iword(ENDSOURCE)
  171. ENDPROC
  172.  
  173. PROC checkstop()
  174.   IF FreeStack()<1000 THEN error(ER_STACK)
  175.   IF CtrlC() THEN error(-1)
  176. ENDPROC
  177.  
  178. PROC eval()                        /* main recursive evaluation function */
  179.   DEF r=0,i,ins,p2,x:PTR TO LONG,a,adr:PTR TO var
  180.   checkstop()
  181.   i:=p[]++
  182.   SELECT i
  183.     CASE VALUE
  184.       r:=^p++
  185.     CASE IDENT
  186.       r:=varvalue(^p++,TINTEGER)
  187.     CASE LBRACKET
  188.       erpos:=^p++
  189.       ins:=p[]++
  190.       IF ins=IDENT
  191.         adr:=findvar(^p++)
  192.         IF adr.type=TFUNC
  193.           r:=dofunc(adr.value)
  194.         ELSE
  195.           IF adr.type<>TARRAY THEN error(ER_TYPE)
  196.           x:=adr.value
  197.           a:=eval()
  198.           IF (a<0) OR (a>x[]) THEN error(ER_ARRAY)
  199.           r:=x[a+1]
  200.         ENDIF
  201.       ELSE
  202.         IF ins<100 THEN error(ER_EXPKEYWORD)
  203.         SELECT ins
  204.           CASE FWRITE                /* output string constants + expressions */
  205.             x:=TRUE
  206.             WHILE p[]<>RBRACKET
  207.               IF p[]=ISTRING
  208.                 Write(stdout,Long(p+4),p[1])
  209.                 IF (p[1]=0) AND (p[4]=RBRACKET) THEN x:=FALSE
  210.                 p:=p+8
  211.               ELSEIF p[]=IDENT
  212.                 IF (Int(findvar(Long(p+2)))=TSTRING)
  213.                   WriteF('\s',eatstring())
  214.                 ELSE
  215.                   WriteF('\d',eval())
  216.                 ENDIF
  217.               ELSE
  218.                 WriteF('\d',eval())
  219.               ENDIF
  220.             ENDWHILE
  221.             IF x THEN WriteF('\n')
  222.           CASE FEQ
  223.             r:=TRUE
  224.             x:=eval()
  225.             WHILE p[]<>RBRACKET DO IF x<>eval() THEN r:=FALSE
  226.           CASE FUNEQ; r:=eval()<>eval()
  227.           CASE FGREATER; r:=eval()>eval()
  228.           CASE FSMALLER; r:=eval()<eval()
  229.           CASE FADD; r:=eval(); WHILE p[]<>RBRACKET DO r:=r+eval()
  230.           CASE FSUB; r:=eval(); WHILE p[]<>RBRACKET DO r:=r-eval()
  231.           CASE FMUL; r:=eval(); WHILE p[]<>RBRACKET DO r:=Mul(r,eval())
  232.           CASE FDIV; r:=eval(); WHILE p[]<>RBRACKET DO r:=r/eval()
  233.           CASE FAND; r:=eval(); WHILE p[]<>RBRACKET DO r:=r AND eval()
  234.           CASE FORX; r:=eval(); WHILE p[]<>RBRACKET DO r:=r OR eval()
  235.           CASE FEOR; r:=eval(); WHILE p[]<>RBRACKET DO r:=Eor(r,eval())
  236.           CASE FNOT; r:=Not(eval())
  237.           CASE FABS; r:=Abs(eval())
  238.           CASE FRND; r:=Rnd(eval())
  239.           CASE FRNDQ; r:=RndQ(eval())
  240.           CASE FKICK; r:=KickVersion(eval())
  241.           CASE FMOD; r:=Mod(eval(),eval())
  242.           CASE FWHEN
  243.             IF eval()
  244.               WHILE (p[]<>FELSE) AND (p[]<>RBRACKET) DO r:=eval()
  245.               IF p[]=FELSE
  246.                 p++
  247.                 WHILE (p[]<>RBRACKET) DO skip()
  248.               ENDIF
  249.             ELSE
  250.               WHILE (p[]<>FELSE) AND (p[]<>RBRACKET) DO skip()
  251.               IF p[]=FELSE
  252.                 p++
  253.                 WHILE (p[]<>RBRACKET) DO r:=eval()
  254.               ENDIF
  255.             ENDIF
  256.           CASE FIF
  257.             IF eval()
  258.               r:=eval()
  259.               IF p[]<>RBRACKET THEN skip()
  260.             ELSE
  261.               skip()
  262.               IF p[]<>RBRACKET THEN r:=eval()
  263.             ENDIF
  264.           CASE FDO; WHILE p[]<>RBRACKET DO r:=eval()
  265.           CASE FSELECT
  266.             x:=eval()
  267.             WHILE p[]<>RBRACKET DO IF x=eval() THEN r:=eval() ELSE skip()
  268.           CASE FSET
  269.             IF p[]=LBRACKET
  270.               p:=p+2
  271.               erpos:=^p++
  272.               x:=varvalue(eatident(),TARRAY)
  273.               a:=eval()
  274.               IF (a<0) OR (a>x[0]) THEN error(ER_ARRAY)
  275.               IF p[]++<>RBRACKET THEN error(ER_EXPRBRACKET)
  276.               x[a+1]:=eval()
  277.             ELSE
  278.               x:=eatident()
  279.               IF (p[]=LBRACKET) AND (p[3]=FLAMBDA)
  280.                 p:=p+8
  281.                 adr:=findvar(x)
  282.                 letvar(adr,p,TFUNC)
  283.                 WHILE p[]<>RBRACKET DO skip()
  284.                 p:=p+2
  285.               ELSEIF p[]=ISTRING
  286.                 r:=eatstring()
  287.                 x:=findvar(x)
  288.                 letvar(x,r,TSTRING)
  289.               ELSE
  290.                 r:=eval()
  291.                 x:=findvar(x)
  292.                 letvar(x,r,TINTEGER)
  293.               ENDIF
  294.             ENDIF
  295.           CASE FINC
  296.             x:=eatident()
  297.             r:=varvalue(x,TINTEGER)
  298.             x:=findvar(x)
  299.             letvar(x,r+1,TINTEGER)
  300.           CASE FDEC
  301.             x:=eatident()
  302.             r:=varvalue(x,TINTEGER)
  303.             x:=findvar(x)
  304.             letvar(x,r-1,TINTEGER)
  305.           CASE FSWAP
  306.             x:=eatident()
  307.             r:=varvalue(x,TINTEGER)
  308.             x:=findvar(x)
  309.             adr:=eatident()
  310.             a:=varvalue(adr,TINTEGER)
  311.             adr:=findvar(adr)
  312.             letvar(x,a,TINTEGER)
  313.             letvar(adr,r,TINTEGER)
  314.             r:=0
  315.           CASE FPOWER
  316.             r:=adr:=eval()
  317.             x:=eval()
  318.             IF x>1 THEN FOR a:=2 TO x DO r:=r*adr
  319.           CASE FFOR
  320.             x:=eatident()
  321.             r:=eval()
  322.             adr:=findvar(x)
  323.             x:=eval()
  324.             p2:=p
  325.             IF r>x               /* downto */
  326.               FOR a:=r TO x STEP -1
  327.                 p:=p2
  328.                 letvar(adr,a,TINTEGER)
  329.                 WHILE p[]<>RBRACKET DO eval()
  330.               ENDFOR
  331.             ELSE
  332.               FOR a:=r TO x
  333.                 p:=p2
  334.                 letvar(adr,a,TINTEGER)
  335.                 WHILE p[]<>RBRACKET DO eval()
  336.               ENDFOR
  337.             ENDIF
  338.             r:=0
  339.           CASE FWHILE
  340.             p2:=p
  341.             WHILE eval()
  342.               WHILE p[]<>RBRACKET DO eval()
  343.               p:=p2
  344.             ENDWHILE
  345.             WHILE p[]<>RBRACKET DO skip()
  346.             r:=0
  347.           CASE FUNTIL
  348.             p2:=p
  349.             WHILE eval()=FALSE
  350.               WHILE p[]<>RBRACKET DO eval()
  351.               p:=p2
  352.             ENDWHILE
  353.             WHILE p[]<>RBRACKET DO skip()
  354.             r:=0
  355.           CASE FDEFUN
  356.             x:=eatident()
  357.             adr:=findvar(x)
  358.             letvar(adr,p,TFUNC)
  359.             WHILE p[]<>RBRACKET DO skip()
  360.           CASE FLAMBDA; error(ER_SYNTAX)
  361.           CASE FAPPLY
  362.             IF p[]<>IDENT
  363.               IF (p[]<>LBRACKET) OR (p[3]<>FLAMBDA) THEN error(ER_EXPIDENT)
  364.               p:=p+8; adr:=p
  365.               WHILE p[]<>RBRACKET DO skip()
  366.               p:=p+2
  367.               r:=dofunc(adr)
  368.             ELSE
  369.               p:=p+2
  370.               r:=dofunc(varvalue(^p++,TFUNC))
  371.             ENDIF
  372.           CASE FREADINT
  373.             IF ReadStr(ownstdin,inputbuf)=-1
  374.               r:=0
  375.             ELSE
  376.               r:=Val(inputbuf)
  377.             ENDIF
  378.           CASE FARRAY
  379.             adr:=findvar(eatident())
  380.             a:=eval()
  381.             x:=New(Mul(a,4)+8)
  382.             IF x=NIL THEN error(ER_ALLOC)
  383.             letvar(adr,x,TARRAY)
  384.             x[]++:=a
  385.             WHILE (p[]++=VALUE)
  386.               IF a-->=0 THEN x[]++:=^p++ ELSE p:=p+4
  387.             ENDWHILE
  388.             p--
  389.           CASE FLOCATE; WriteF('\e[\d;\dH',eval(),eval())
  390.           CASE FCLS; Out(stdout,12)
  391.           CASE FDUMP
  392.             adr:=varbottom
  393.             WriteF('\n')
  394.             WHILE adr<vartop
  395.               a:=adr.name
  396.               x:=a
  397.               WHILE Char(x)<>" " DO INC x
  398.               Write(stdout,a,x-a)
  399.               x:=adr.type
  400.               SELECT x
  401.                 CASE TINTEGER; WriteF(' = \d (int)\n',adr.value)
  402.                 CASE TSTRING;  WriteF(' = "\s" (string)\n',adr.value)
  403.                 CASE TFUNC;    WriteF(' (function)\n')
  404.                 CASE TARRAY;   WriteF('[\d] (array)\n',Long(adr.value))
  405.               ENDSELECT
  406.               adr:=adr+SIZEOF var
  407.             ENDWHILE
  408.             WriteF('\n')
  409.           CASE FWINDOW
  410.             StringF(winspec,'CON:\d/\d/\d/\d/',eval(),eval(),eval(),eval())
  411.             x:=eatstring()
  412.             StrAdd(winspec,x,ALL)
  413.             wfile:=Open(winspec,1006)
  414.             IF wfile=NIL THEN error(ER_FILE)
  415.             IF conout<>NIL THEN Close(conout)
  416.             stdout:=wfile
  417.             conout:=stdout
  418.             ownstdin:=stdout
  419.             adr:=OpenWorkBench()
  420.             Forbid()
  421.             a:=NIL
  422.             IF adr<>NIL
  423.               adr:=Long(adr+4)
  424.               WHILE (adr<>NIL) AND (a=NIL)
  425.                 IF StrCmp(x,Long(adr+32),ALL) THEN a:=adr
  426.                 adr:=^adr
  427.               ENDWHILE
  428.             ENDIF
  429.             Permit()
  430.             IF a THEN gfxwindow:=a
  431.           CASE FREQ
  432.             IF KickVersion(37)=FALSE THEN error(ER_KICK)
  433.             r:=EasyRequestArgs(IF curwindow THEN curwindow ELSE NIL,
  434.                    [20,0,eatstring(),eatstring(),eatstring()],0,NIL)
  435.           CASE FTELL
  436.             IF outfile<>NIL THEN Close(outfile)
  437.             outfile:=NIL
  438.             outfile:=Open(eatstring(),1006)
  439.             IF outfile=NIL THEN error(ER_FILE)
  440.             oldout:=stdout
  441.             stdout:=outfile
  442.           CASE FTOLD
  443.             IF outfile<>NIL THEN Close(outfile)
  444.             outfile:=NIL
  445.             stdout:=oldout
  446.           CASE FSEE
  447.             IF infile<>NIL THEN Close(infile)
  448.             infile:=NIL
  449.             infile:=Open(eatstring(),1005)
  450.             IF infile=NIL THEN error(ER_FILE)
  451.             oldin:=ownstdin
  452.             ownstdin:=infile
  453.           CASE FSEEN
  454.             IF infile<>NIL THEN Close(infile)
  455.             infile:=NIL
  456.             ownstdin:=oldin
  457.           CASE FSTRING
  458.             adr:=String(250)
  459.             IF adr=NIL THEN error(ER_ALLOC)
  460.             letvar(findvar(eatident()),adr,TSTRING)
  461.           CASE FREAD
  462.             x:=varvalue(eatident(),TSTRING)
  463.             r:=ReadStr(ownstdin,x)
  464.           CASE FGET; r:=Inp(ownstdin)
  465.           CASE FPUT; r:=eval(); IF r<>-1 THEN Out(stdout,r)
  466.           CASE FFILELEN
  467.             r:=FileLength(eatstring())
  468.             IF r=-1 THEN r:=0
  469.           CASE FLINE; getrast(); Line(eval(),eval(),eval(),eval(),eval())
  470.           CASE FPLOT; getrast(); Plot(eval(),eval(),eval())
  471.           CASE FBOX
  472.             getrast()
  473.             a:=eval(); x:=eval(); p2:=eval(); r:=eval()
  474.             IF a>p2
  475.               adr:=a; a:=p2; p2:=adr
  476.             ENDIF
  477.             IF x>r
  478.               adr:=x; x:=r; r:=adr
  479.             ENDIF
  480.             IF (a<0) OR (x<0) OR (p2>10000) OR (r>10000) THEN error(ER_VALUES)
  481.             Box(a,x,p2,r,eval())
  482.             r:=0
  483.           CASE FMOUSEX; r:=MouseX(getwin())
  484.           CASE FMOUSEY; r:=MouseY(getwin())
  485.           CASE FMOUSE; r:=Mouse()
  486.           CASE FTEXT
  487.             adr:=getrast()
  488.             a:=eval(); x:=eval()
  489.             Colour(eval(),eval())
  490.             TextF(a,x,eatstring())
  491.             r:=0
  492.           CASE FMESSAGE
  493.             r:=WaitIMessage(getwin())
  494.             gadnum:=IF (r=$20) OR (r=$40) THEN Long(MsgIaddr()+40) ELSE -1
  495.           CASE FGADNUM
  496.             r:=gadnum
  497.           CASE FGADGET
  498.             IF (adr:=New(GADGETSIZE))=NIL THEN error(ER_ALLOC)
  499.             Gadget(adr,NIL,eval(),0,eval(),eval(),eval(),eatstring())
  500.             AddGadget(getwin(),adr,-1)
  501.             RefreshGList(adr,getwin(),NIL,1)
  502.           CASE FSCREEN
  503.             CloseS(curscreen)
  504.             curscreen:=NIL
  505.             curscreen:=OpenS(eval(),eval(),eval(),eval(),eatstring())
  506.           CASE FWIN
  507.             CloseW(curwindow)
  508.             curwindow:=NIL
  509.             gfxwindow:=NIL
  510.             curwindow:=OpenW(eval(),eval(),eval(),eval(),
  511.                              eval(),eval(),eatstring(),
  512.                              IF curscreen THEN curscreen ELSE NIL,
  513.                              IF curscreen THEN 15 ELSE 1,NIL)
  514.             gfxwindow:=curwindow
  515.           CASE FHEX
  516.             WriteF('$\z\h[8]',eval())
  517.           CASE FEXIT
  518.             error(0)
  519.         ENDSELECT
  520.       ENDIF
  521.       IF p[]++<>RBRACKET THEN error(ER_EXPRBRACKET)
  522.     DEFAULT
  523.       IF (i=RBRACKET) OR (i=ISTRING) THEN error(ER_EXPEXP) ELSE error(ER_SYNTAX)
  524.   ENDSELECT
  525. ENDPROC r
  526.  
  527. PROC getwin()
  528.   IF gfxwindow=NIL THEN error(ER_GFXWIN)
  529. ENDPROC gfxwindow
  530.  
  531. PROC getrast()
  532.   DEF r
  533.   IF curwindow=NIL
  534.     IF curscreen=NIL
  535.       IF gfxwindow=NIL THEN error(ER_GFXWIN)
  536.       r:=Long(gfxwindow+50)
  537.     ELSE
  538.       r:=curscreen+84
  539.     ENDIF
  540.   ELSE
  541.     r:=Long(curwindow+50)
  542.   ENDIF
  543.   SetStdRast(r)
  544. ENDPROC r
  545.  
  546. PROC eatstring()
  547.   DEF adr,x
  548.   IF p[]=ISTRING
  549.     p:=p+2; x:=p[]++; adr:=^p++
  550.     adr[x]:=0
  551.   ELSE
  552.     adr:=varvalue(eatident(),TSTRING)
  553.   ENDIF
  554. ENDPROC adr
  555.  
  556. PROC eatident()
  557.   IF p[]++<>IDENT THEN error(ER_EXPIDENT)
  558. ENDPROC ^p++
  559.  
  560. PROC dofunc(lcode)
  561.   DEF args[MAXARGS]:ARRAY OF LONG,a=0,oldvarb,oldvart,oldp,x,r=0,olderpos
  562.   checkstop()
  563.   WHILE p[]<>RBRACKET
  564.     IF a=MAXARGS THEN error(ER_ARGS)
  565.     args[a]:=eval()
  566.     INC a
  567.   ENDWHILE
  568.   IF rec=0 THEN globvar:=vartop
  569.   oldvarb:=varbottom; varbottom:=vartop; oldvart:=vartop;
  570.   oldp:=p; p:=lcode; olderpos:=erpos; INC rec
  571.   IF p[]++<>LBRACKET THEN error(ER_EXPLBRACKET)
  572.   erpos:=^p++
  573.   WHILE p[]<>RBRACKET
  574.     IF a=0 THEN error(ER_ARGS)
  575.     x:=findvar(eatident())
  576.     letvar(x,args[]++,TINTEGER)
  577.     DEC a
  578.   ENDWHILE
  579.   IF a<>0 THEN error(ER_ARGS)
  580.   p:=p+2
  581.   WHILE p[]<>RBRACKET DO r:=eval()
  582.   varbottom:=oldvarb; vartop:=oldvart; p:=oldp; erpos:=olderpos; DEC rec
  583. ENDPROC r
  584.  
  585. PROC findvar(id)
  586.   DEF loc=0:PTR TO var,a:PTR TO var
  587.   IF vartop<>varbottom
  588.     a:=varbottom                     /* check existing local vars */
  589.     WHILE (a<vartop) AND (loc=0)
  590.       IF a.name=id THEN loc:=a
  591.       a:=a+SIZEOF var
  592.     ENDWHILE
  593.   ENDIF
  594.   IF loc=0
  595.     IF (rec>0) AND (globvar>vars)    /* check global vars */
  596.       a:=vars
  597.       WHILE (a<globvar) AND (loc=0)
  598.         IF a.name=id THEN loc:=a
  599.         a:=a+SIZEOF var
  600.       ENDWHILE
  601.     ENDIF
  602.     IF loc=0                         /* create new var dynamically */
  603.       loc:=vartop
  604.       vartop:=vartop+SIZEOF var
  605.       IF vars+VARSTACKSPACE<vartop THEN error(ER_WORKSPACE)
  606.       loc.type:=TINTEGER
  607.       loc.name:=id
  608.       loc.value:=0
  609.     ENDIF
  610.   ENDIF
  611. ENDPROC loc
  612.  
  613. PROC letvar(adr:PTR TO var,value,type)
  614.   IF (adr.type<>type) AND (adr.type<>TINTEGER) THEN error(ER_TYPE)
  615.   checkstop()
  616.   adr.type:=type
  617.   adr.value:=value
  618. ENDPROC
  619.  
  620. PROC varvalue(id,type)
  621.   DEF adr:PTR TO var
  622.   checkstop()
  623.   adr:=findvar(id)
  624.   IF adr.type<>type THEN error(ER_TYPE)
  625. ENDPROC adr.value
  626.  
  627. PROC skip()                        /* skip *one* expression */
  628.   DEF deep=0,i
  629.   REPEAT
  630.     i:=p[]++
  631.     IF (i=VALUE) OR (i=LBRACKET) OR (i=IDENT) THEN p:=p+4
  632.     IF i=ISTRING THEN p:=p+6
  633.     IF i=LBRACKET THEN INC deep
  634.     IF i=RBRACKET THEN IF deep=0 THEN error(ER_EXPEXP) ELSE DEC deep
  635.     IF i=ENDSOURCE THEN error(ER_EXPRBRACKET)
  636.   UNTIL deep=0
  637. ENDPROC
  638.  
  639. PROC iword(x)
  640.   IF ibuf+ilen>ipos THEN ipos[]++:=x ELSE error(ER_BUF)
  641. ENDPROC
  642.  
  643. PROC ilong(x)
  644.   IF ibuf+ilen>ipos THEN ^ipos++:=x ELSE error(ER_BUF)
  645. ENDPROC
  646.  
  647. PROC loadsource()
  648.   DEF suxxes=FALSE,handle,read
  649.   IF StrCmp(arg,'?',ALL) OR StrCmp(arg,'',ALL)
  650.     WriteF('USAGE: Yax <source> (default ext. ".yax")\n')
  651.     error(0)
  652.   ELSE
  653.     StrCopy(name,arg,ALL)
  654.     StrAdd(name,'.yax',4)
  655.     slen:=FileLength(name)
  656.     handle:=Open(name,1005)
  657.     IF (handle=NIL) OR (slen=-1)
  658.       error(ER_INFILE)
  659.     ELSE
  660.       source:=New(slen+10)
  661.       IF source=NIL
  662.         error(ER_SOURCEMEM)
  663.       ELSE
  664.         read:=Read(handle,source,slen)
  665.         Close(handle)
  666.         IF read=slen 
  667.           suxxes:=TRUE
  668.           source[slen]:=0
  669.         ELSE
  670.           error(ER_INFILE)
  671.         ENDIF
  672.       ENDIF
  673.     ENDIF
  674.   ENDIF
  675. ENDPROC
  676.  
  677. PROC error(nr)
  678.   DEF erstr[ERLEN]:STRING,a
  679.   IF outfile
  680.     IF stdout=outfile THEN stdout:=oldout
  681.     Close(outfile)
  682.   ENDIF
  683.   IF infile
  684.     IF ownstdin=infile THEN ownstdin:=oldin
  685.     Close(infile)
  686.   ENDIF
  687.   CloseW(curwindow)
  688.   CloseS(curscreen)
  689.   WriteF('\n')
  690.   IF nr>0
  691.     WriteF('ERROR: ')
  692.     SELECT nr
  693.       CASE ER_WORKSPACE;   WriteF('Could not allocate workspace!\n')
  694.       CASE ER_BUF;         WriteF('Buffer overflow!\n')
  695.       CASE ER_GARBAGE;     WriteF('Garbage in line\n')
  696.       CASE ER_SYNTAX;      WriteF('Your syntax sucks\n')
  697.       CASE ER_EXPKEYWORD;  WriteF('Keyword identifier expected\n')
  698.       CASE ER_EXPRBRACKET; WriteF('Right bracket expected\n')
  699.       CASE ER_EXPEXP;      WriteF('Evaluateable expression expected\n')
  700.       CASE ER_QUOTE;       WriteF('Missing quote \a\n')
  701.       CASE ER_COMMENT;     WriteF('Missing "*/"\n')
  702.       CASE ER_SOURCEMEM;   WriteF('No Memory for source!\n')
  703.       CASE ER_INFILE;      WriteF('Could not open file "\s".\n',name)
  704.       CASE ER_EXPIDENT;    WriteF('Identifier expected\n')
  705.       CASE ER_ARGS;        WriteF('Illegal #of arguments\n')
  706.       CASE ER_TYPE;        WriteF('Wrong type of variable/expression\n')
  707.       CASE ER_EXPLBRACKET; WriteF('Left bracket expected\n')
  708.       CASE ER_STACK;       WriteF('Nearly stack overflow: \d deep\n',rec)
  709.       CASE ER_ALLOC;       WriteF('Dynamic allocation failed!\n')
  710.       CASE ER_ARRAY;       WriteF('Array index out of bounds\n')
  711.       CASE ER_FILE;        WriteF('File error\n')
  712.       CASE ER_GFXWIN;      WriteF('No User-window for graphics\n')
  713.       CASE ER_VALUES;      WriteF('Illegal value(s)\n')
  714.       CASE ER_KICK;        WriteF('You need OS 37+ for this function\n')
  715.     ENDSELECT
  716.     IF erpos<>NIL
  717.       StrCopy(erstr,erpos,ALL)
  718.       FOR a:=0 TO ERLEN-1 DO IF erstr[a]=10 THEN erstr[a]:=32
  719.       WriteF('NEARBY: \s\n',erstr)
  720.     ENDIF
  721.   ELSEIF nr=-1
  722.     WriteF('*** Program halted.\n')
  723.   ENDIF
  724.   IF conout<>NIL THEN WriteF('Press <return> to continue ...\n')
  725.   CleanUp(0)
  726. ENDPROC
  727.  
  728. keywords:
  729. CHAR 'write...', 'add.....', 'eq......', 'uneq....', 'sub.....',
  730.      'mul.....', 'div.....', 'and.....', 'or......', 'not.....',
  731.      'if......', 'do......', 'select..', 'set.....', 'for.....',
  732.      'while...', 'until...', 'defun...', 'lambda..', 'apply...',
  733.      'readint.', 'array...', 'greater.', 'smaller.', 'locate..',
  734.      'cls.....', 'dump....', 'window..', 'tell....', 'told....',
  735.      'see.....', 'seen....', 'string..', 'read....', 'get.....',
  736.      'put.....', 'filelen.', 'line....', 'plot....', 'box.....',
  737.      'mousex..', 'mousey..', 'mouse...', 'text....', 'abs.....',
  738.      'mod.....', 'eor.....', 'swap....', 'power...', 'req.....',
  739.      'inc.....', 'dec.....', 'rnd.....', 'rndq....', 'kick....',
  740.      'when....', 'else....', 'win.....', 'screen..', 'message.',
  741.      'gadget..', 'gadid...', 'hex.....', 'exit....'
  742.  
  743.